Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume13 / gmcalc / part05 < prev next >

Wrap

Text File | 1990-06-05 | 57.2 KB | 1,868 lines

Newsgroups: comp.sources.misc From: daveg@csvax.caltech.edu (David Gillespie) Subject: v13i031: Emacs Calculator 1.01, part 05/19 Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 13, Issue 31 Submitted-by: daveg@csvax.caltech.edu (David Gillespie) Archive-name: gmcalc/part05 ---- Cut Here and unpack ---- #!/bin/sh # this is part 5 of a multipart archive # do not concatenate these parts, unpack them in order with /bin/sh # file calc-ext.el continued # CurArch=5 if test ! -r s2_seq_.tmp then echo "Please unpack part 1 first!" exit 1; fi ( read Scheck if test "$Scheck" != $CurArch then echo "Please unpack part $Scheck next!" exit 1; else exit 0; fi ) < s2_seq_.tmp || exit 1 echo "x - Continuing file calc-ext.el" sed 's/^X//' << 'SHAR_EOF' >> calc-ext.el X ( atan . calcFunc-arctan ) X ( atan2 . calcFunc-arctan2 ) X ( atanh . calcFunc-arctanh ) X)) X X(put 'c 'math-variable-table X '( ( M_PI . var-pi ) X ( M_E . var-e ) X)) X X(put 'c 'math-vector-brackets "{}") X X(put 'c 'math-radix-formatter X (function (lambda (r s) X (if (= r 16) (format "0x%s" s) X (if (= r 8) (format "0%s" s) X (format "%d#%s" r s)))))) X X X(defun calc-pascal-language (n) X "Set Pascal-language entry and display notation." X (interactive "P") X (calc-wrapper X (calc-set-language 'pascal n)) X) X X(put 'pascal 'math-oper-table X '( ( "not" calcFunc-lnot -1 1000 ) X ( "*" * 190 191 ) X ( "/" / 190 191 ) X ( "and" calcFunc-and 190 191 ) X ( "div" calcFunc-idiv 190 191 ) X ( "mod" % 190 191 ) X ( "u+" ident -1 185 ) X ( "u-" neg -1 185 ) X ( "+" + 180 181 ) X ( "-" - 180 181 ) X ( "or" calcFunc-or 180 181 ) X ( "xor" calcFunc-xor 180 181 ) X ( "shl" calcFunc-lsh 180 181 ) X ( "shr" calcFunc-rsh 180 181 ) X ( "in" calcFunc-in 160 161 ) X ( "<" calcFunc-lt 160 161 ) X ( ">" calcFunc-gt 160 161 ) X ( "<=" calcFunc-leq 160 161 ) X ( ">=" calcFunc-geq 160 161 ) X ( "=" calcFunc-eq 160 161 ) X ( "<>" calcFunc-neq 160 161 ) X ( ":=" calcFunc-assign 81 80 ) X)) X X(put 'pascal 'math-input-filter 'calc-input-case-filter) X(put 'pascal 'math-output-filter 'calc-output-case-filter) X X(defun calc-input-case-filter (str) X (cond ((or (null calc-language-option) (= calc-language-option 0)) X str) X (t X (downcase str))) X) X X(defun calc-output-case-filter (str) X (cond ((or (null calc-language-option) (= calc-language-option 0)) X str) X ((> calc-language-option 0) X (upcase str)) X (t X (downcase str))) X) X X X(defun calc-fortran-language (n) X "Set Fortran-language entry and display notation." X (interactive "P") X (calc-wrapper X (calc-set-language 'fortran n)) X) X X(put 'fortran 'math-oper-table X '( ( "**" ^ 201 200 ) X ( "u+" ident -1 191 ) X ( "u-" neg -1 191 ) X ( "*" * 190 191 ) X ( "/" / 190 191 ) X ( "+" + 180 181 ) X ( "-" - 180 181 ) X)) X X(put 'fortran 'math-vector-brackets "//") X X(put 'fortran 'math-function-table X '( ( acos . calcFunc-arccos ) X ( acosh . calcFunc-arccosh ) X ( aimag . calcFunc-im ) X ( aint . calcFunc-ftrunc ) X ( asin . calcFunc-arcsin ) X ( asinh . calcFunc-arcsinh ) X ( atan . calcFunc-arctan ) X ( atan2 . calcFunc-arctan2 ) X ( atanh . calcFunc-arctanh ) X ( conjg . calcFunc-conj ) X ( log . calcFunc-ln ) X ( nint . calcFunc-round ) X ( real . calcFunc-re ) X)) X X(put 'fortran 'math-input-filter 'calc-input-case-filter) X(put 'fortran 'math-output-filter 'calc-output-case-filter) X X X(defun calc-tex-language (n) X "Set TeX entry and display notation." X (interactive "P") X (calc-wrapper X (calc-set-language 'tex n)) X) X X(put 'tex 'math-oper-table X '( ( "u+" ident -1 1000 ) X ( "u-" neg -1 1000 ) X ( "u|" calcFunc-abs -1 0 ) X ( "|" ident 0 -1 ) X ( "\\lfloor" calcFunc-floor -1 0 ) X ( "\\rfloor" ident 0 -1 ) X ( "\\lceil" calcFunc-ceil -1 0 ) X ( "\\rceil" ident 0 -1 ) X ( "\\pm" sdev 300 300 ) X ( "!" calcFunc-fact 210 -1 ) X ( "^" ^ 201 200 ) X ( "_" calcFunc-subscr 201 200 ) X ( "\\times" * 191 190 ) X ( "2x" * 191 190 ) X ( "+" + 180 181 ) X ( "-" - 180 181 ) X ( "\\over" / 170 171 ) X ( "/" / 170 171 ) X ( "\\choose" calcFunc-choose 170 171 ) X ( "\\mod" % 170 171 ) X)) X X(put 'tex 'math-function-table X '( ( \\arccos . calcFunc-arccos ) X ( \\arcsin . calcFunc-arcsin ) X ( \\arctan . calcFunc-arctan ) X ( \\arg . calcFunc-arg ) X ( \\cos . calcFunc-cos ) X ( \\cosh . calcFunc-cosh ) X ( \\det . calcFunc-det ) X ( \\exp . calcFunc-exp ) X ( \\gcd . calcFunc-gcd ) X ( \\ln . calcFunc-ln ) X ( \\log . calcFunc-log10 ) X ( \\max . calcFunc-max ) X ( \\min . calcFunc-min ) X ( \\tan . calcFunc-tan ) X ( \\sin . calcFunc-sin ) X ( \\sinh . calcFunc-sinh ) X ( \\tanh . calcFunc-tanh ) X ( \\phi . calcFunc-totient ) X ( \\mu . calcFunc-moebius ) X)) X X(put 'tex 'math-variable-table X '( ( \\pi . var-pi ) X)) X X(put 'tex 'math-complex-format 'i) X X X(defun calc-mathematica-language () X "Set Mathematica(tm) entry and display notation." X (interactive) X (calc-wrapper X (calc-set-language 'math)) X) X X(put 'math 'math-oper-table X '( ( "!" calcFunc-fact 210 -1 ) X ( "!!" calcFunc-dfact 210 -1 ) X ( "^" ^ 201 200 ) X ( "u+" ident -1 197 ) X ( "u-" neg -1 197 ) X ( "/" / 195 196 ) X ( "*" * 190 191 ) X ( "2x" * 190 191 ) X ( "+" + 180 181 ) X ( "-" - 180 181 ) X ( "<" calcFunc-lt 160 161 ) X ( ">" calcFunc-gt 160 161 ) X ( "<=" calcFunc-leq 160 161 ) X ( ">=" calcFunc-geq 160 161 ) X ( "==" calcFunc-eq 150 151 ) X ( "!=" calcFunc-neq 150 151 ) X ( "&&" calcFunc-land 110 111 ) X ( "||" calcFunc-lor 100 101 ) X)) X X(put 'math 'math-function-table X '( ( Abs . calcFunc-abs ) X ( ArcCos . calcFunc-arccos ) X ( ArcCosh . calcFunc-arccosh ) X ( ArcSin . calcFunc-arcsin ) X ( ArcSinh . calcFunc-arcsinh ) X ( ArcTan . calcFunc-arctan ) X ( ArcTanh . calcFunc-arctanh ) X ( Arg . calcFunc-arg ) X ( Binomial . calcFunc-choose ) X ( Ceiling . calcFunc-ceil ) X ( Conjugate . calcFunc-conj ) X ( Cos . calcFunc-cos ) X ( Cosh . calcFunc-cosh ) X ( D . calcFunc-deriv ) X ( Dt . calcFunc-tderiv ) X ( Det . calcFunc-det ) X ( Exp . calcFunc-exp ) X ( EulerPhi . calcFunc-totient ) X ( Floor . calcFunc-floor ) X ( Gamma . calcFunc-gamma ) X ( GCD . calcFunc-gcd ) X ( If . calcFunc-if ) X ( Im . calcFunc-im ) X ( Inverse . calcFunc-inv ) X ( Join . calcFunc-vconcat ) X ( LCM . calcFunc-lcm ) X ( Log . calcFunc-ln ) X ( Max . calcFunc-max ) X ( Min . calcFunc-min ) X ( Mod . calcFunc-mod ) X ( MoebiusMu . calcFunc-moebius ) X ( Random . calcFunc-random ) X ( Round . calcFunc-round ) X ( Re . calcFunc-re ) X ( Sign . calcFunc-sign ) X ( Sin . calcFunc-sin ) X ( Sinh . calcFunc-sinh ) X ( Sqrt . calcFunc-sqrt ) X ( Tan . calcFunc-tan ) X ( Tanh . calcFunc-tanh ) X ( Transpose . calcFunc-trn ) X ( Length . calcFunc-vlen ) X)) X X(put 'math 'math-variable-table X '( ( I . var-i ) X ( Pi . var-pi ) X ( E . var-e ) X)) X X(put 'math 'math-vector-brackets "{}") X(put 'math 'math-complex-format 'I) X(put 'math 'math-function-open "[") X(put 'math 'math-function-close "]") X X(put 'math 'math-radix-formatter X (function (lambda (r s) (format "%d^^%s" r s)))) X X X X X;;; Combinatorics X X(defun calc-k-prefix-help () X (interactive) X (calc-do-prefix-help X '("GCD, LCM; Binomial, Dbl-fact; Random, random-Again" X "Factors, Prime-test, Next-prime, Totient, Moebius" X "SHIFT + extended-GCD") X "combinatorics" ?k) X) X X(defun calc-gcd (arg) X "Compute the GCD of the top two elements of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "gcd" 'calcFunc-gcd arg)) X) X X(defun calc-lcm (arg) X "Compute the LCM of the top two elements of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "lcm" 'calcFunc-lcm arg)) X) X X(defun calc-extended-gcd () X "Compute the extended GCD of the top two elements of the Calculator stack. XThis is a list [g,a,b] where g = gcd(x,y) = ax + by, and x and y are the Xsecond-to-top and top values on the stack, respectively." X (interactive) X (calc-slow-wrapper X (calc-enter-result 2 "egcd" (cons 'calcFunc-egcd (calc-top-list-n 2)))) X) X X(defun calc-factorial (arg) X "Compute the factorial of the number on the top of the Calculator stack. XIf the number is an integer, computes an exact result. XIf the number is floating-point, computes a floating-point approximate result." X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "fact" 'calcFunc-fact arg)) X) X X(defun calc-gamma (arg) X "Compute the Euler Gamma function of the number on the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "gmma" 'calcFunc-gamma arg)) X) X X(defun calc-double-factorial (arg) X "Compute the double factorial of the number on the Calculator stack. XFor even numbers, this is the product of even integers up to N. XFor odd numbers, this is the product of odd integers up to N. XIf the number is an integer, computes an exact result. XIf the number is floating-point, computes a floating-point approximate result." X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "dfac" 'calcFunc-dfact arg)) X) X X(defun calc-choose (arg) X "Compute the binomial coefficient C(N,M) of the numbers on the stack. XIf the numbers are integers, computes an exact result. XIf either number is floating-point, computes an approximate result. XWith Hyperbolic flag, computes number-of-permutations instead." X (interactive "P") X (calc-slow-wrapper X (if (calc-is-hyperbolic) X (calc-binary-op "perm" 'calcFunc-perm arg) X (calc-binary-op "chos" 'calcFunc-choose arg))) X) X X(defun calc-perm (arg) X "Compute the number-of-permutations P(N,M) of the numbers on the stack. XIf the numbers are integers, computes an exact result. XIf either number is floating-point, computes an approximate result. XWith Hyperbolic flag, computes binomial coefficient instead." X (interactive "P") X (calc-hyperbolic-func) X (calc-choose arg) X) X X(defvar calc-last-random-limit '(float 1 0)) X(defun calc-random (n) X "Produce a random integer between 0 (inclusive) and N (exclusive). XN is the numeric prefix argument, if any, otherwise it is taken from the stack. XIf N is real, produce a random real number in the specified range. XIf N is zero, produce a Gaussian-distributed value with mean 0, variance 1." X (interactive "P") X (calc-slow-wrapper X (if n X (calc-enter-result 0 "rand" (list 'calcFunc-random X (setq calc-last-random-limit X (prefix-numeric-value n)))) X (calc-enter-result 1 "rand" (list 'calcFunc-random X (setq calc-last-random-limit X (calc-top-n 1)))))) X) X X(defun calc-rrandom () X "Produce a random real between 0 and 1." X (interactive) X (calc-slow-wrapper X (setq calc-last-random-limit '(float 1 0)) X (calc-enter-result 0 "rand" (list 'calcFunc-random '(float 1 0)))) X) X X(defun calc-random-again () X "Produce another random number in the same range as the last one generated." X (interactive) X (calc-slow-wrapper X (calc-enter-result 0 "rand" (list 'calcFunc-random calc-last-random-limit))) X) X X(defun calc-report-prime-test (res) X (cond ((eq (car res) t) X (calc-record-message "prim" "Prime (guaranteed)")) X ((eq (car res) nil) X (if (cdr res) X (if (eq (nth 1 res) 'unknown) X (calc-record-message X "prim" "Non-prime (factors unknown)") X (calc-record-message X "prim" "Non-prime (%s is a factor)" X (math-format-number (nth 1 res)))) X (calc-record-message "prim" "Non-prime"))) X (t X (calc-record-message X "prim" "Probably prime (%d iters; %s%% chance of error)" X (nth 1 res) X (let ((calc-float-format '(fix 2))) X (math-format-number (nth 2 res)))))) X) X X(defun calc-prime-test (iters) X "Determine whether the number on the top of the stack is prime. XFor large numbers (> 8 million), this test is probabilistic. XExecute this command repeatedly to improve certainty of result. XWith a numeric prefix argument, execute (up to) N iterations at once." X (interactive "p") X (calc-slow-wrapper X (let* ((n (calc-top-n 1)) X (res (math-prime-test n iters))) X (calc-report-prime-test res))) X) X X(defun calc-next-prime (iters) X "Determine the next prime greater than the number on the top of the stack. XThe top-of-stack is replaced by this number. XFor numbers above 8 million, this finds the next number that passes one Xiteration of calc-prime-test. With a prefix argument, the number must Xpass the specified number of calc-prime-test iterations. XWith Inverse flag, find the previous prime instead." X (interactive "p") X (calc-slow-wrapper X (let ((calc-verbose-nextprime t)) X (if (calc-is-inverse) X (calc-enter-result 1 "prvp" (list 'calcFunc-prevprime X (calc-top-n 1) (math-abs iters))) X (calc-enter-result 1 "nxtp" (list 'calcFunc-nextprime X (calc-top-n 1) (math-abs iters)))))) X) X X(defun calc-prev-prime (iters) X "Determine the next prime less than the number on the top of the stack. XWith Inverse flag, find the next greater prime instead." X (interactive "p") X (calc-invert-func) X (calc-next-prime iters) X) X X(defun calc-prime-factors (iters) X "Attempt to reduce the integer at top of stack to a list of its prime factors. XThis algorithm is guaranteed for N up to 25 million. For larger N, it may Xnot find all of the prime factors." X (interactive "p") X (calc-slow-wrapper X (let ((res (math-prime-factors (calc-top-n 1)))) X (if (not math-prime-factors-finished) X (calc-record-message "pfac" "Warning: May not be fully factored")) X (calc-enter-result 1 "pfac" res))) X) X X(defun calc-totient (arg) X "Compute the Euler Totient function phi(n). XThis is the number of integers less than n which are relatively prime to n." X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "phi" 'calcFunc-totient arg)) X) X X(defun calc-moebius (arg) X "Compute the Moebius Mu function mu(n). XThis is (-1)^k if n has k distinct prime factors, or 0 if n has some Xduplicate factors." X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "mu" 'calcFunc-moebius arg)) X) X X X X X;;; Mode commands. X X(defun calc-m-prefix-help () X (interactive) X (calc-do-prefix-help X '("Deg, Rad, HMS; Frac; Polar; Algebraic; Symbolic" X "Working; Xtensions; M=save" X "SHIFT + simplify: Off, Num, Default, Bin-clip, Alg, Units") X "mode" ?m) X) X X(defun calc-save-modes () X "Save all mode variables' values in your .emacs file." X (interactive) X (calc-wrapper X (let (pos X (vals (mapcar (function (lambda (v) (symbol-value (car v)))) X calc-mode-var-list))) X (set-buffer (find-file-noselect (substitute-in-file-name X calc-settings-file))) X (goto-char (point-min)) X (if (and (search-forward ";;; Mode settings stored by Calc" nil t) X (progn X (beginning-of-line) X (setq pos (point)) X (search-forward "\n;;; End of mode settings" nil t))) X (progn X (beginning-of-line) X (forward-line 1) X (delete-region pos (point))) X (goto-char (point-max)) X (insert "\n\n") X (forward-char -1)) X (insert ";;; Mode settings stored by Calc on " (current-time-string) "\n") X (let ((list calc-mode-var-list)) X (while list X (let* ((v (car (car list))) X (def (nth 1 (car list))) X (val (car vals))) X (or (equal val def) X (progn X (insert "(setq " (symbol-name v) " ") X (if (and (or (listp val) X (symbolp val)) X (not (memq val '(nil t)))) X (insert "'")) X (insert (prin1-to-string val) ")\n")))) X (setq list (cdr list) X vals (cdr vals)))) X (run-hooks 'calc-mode-save-hook) X (insert ";;; End of mode settings\n") X (save-buffer))) X) X X(defun calc-algebraic-mode () X "Turn Algebraic mode on or off. XIn algebraic mode, numeric entry accepts whole expressions without needing \"'\"." X (interactive) X (calc-wrapper X (setq calc-algebraic-mode (not calc-algebraic-mode))) X) X X(defun calc-symbolic-mode () X "Turn Symbolic mode on or off. XIn symbolic mode, inexact numeric computations like sqrt(2) are postponed." X (interactive) X (calc-wrapper X (setq calc-symbolic-mode (not calc-symbolic-mode))) X) X X(defun calc-set-simplify-mode (mode arg) X (setq calc-simplify-mode (if arg X (and (> (prefix-numeric-value arg) 0) X mode) X (and (not (eq calc-simplify-mode mode)) X mode))) X) X X(defun calc-no-simplify-mode (arg) X "Turn off automatic simplification of algebraic expressions." X (interactive "P") X (calc-wrapper X (calc-set-simplify-mode 'none arg)) X) X X(defun calc-num-simplify-mode (arg) X "Enable automatic simplification of expressions with constant argments only." X (interactive "P") X (calc-wrapper X (calc-set-simplify-mode 'num arg)) X) X X(defun calc-default-simplify-mode () X "Turn on default automatic simplification of algebraic expressions." X (interactive) X (calc-wrapper X (setq calc-simplify-mode nil)) X) X X(defun calc-bin-simplify-mode (arg) X "Turn on automatic simplification with math-clip." X (interactive "P") X (calc-wrapper X (calc-set-simplify-mode 'binary arg)) X) X X(defun calc-alg-simplify-mode (arg) X "Turn on automatic algebraic simplification of expressions." X (interactive "P") X (calc-wrapper X (calc-set-simplify-mode 'alg arg)) X) X X(defun calc-ext-simplify-mode (arg) X "Turn on automatic \"extended\" algebraic simplification of expressions." X (interactive "P") X (calc-wrapper X (calc-set-simplify-mode 'ext arg)) X) X X(defun calc-units-simplify-mode (arg) X "Turn on automatic units-simplification of expressions." X (interactive "P") X (calc-wrapper X (calc-set-simplify-mode 'units arg)) X) X X(defun calc-working (n) X "Display level of \"Working...\" messages, or set level to N. XWith numeric prefix argument 0, disables messages. XWith argument 1, enables messages. XWith argument 2, enables more detailed messages." X (interactive "P") X (calc-wrapper X (cond ((consp n) X (calc-pop-push-record 0 "work" X (cond ((eq calc-display-working-message t) 1) X (calc-display-working-message 2) X (t 0)))) X ((eq n 2) (setq calc-display-working-message 'lots)) X ((eq n 0) (setq calc-display-working-message nil)) X ((eq n 1) (setq calc-display-working-message t))) X (cond ((eq calc-display-working-message t) X (message "\"Working...\" messages enabled.")) X (calc-display-working-message X (message "Detailed \"Working...\" messages enabled.")) X (t X (message "\"Working...\" messages disabled.")))) X) X X(defun calc-always-load-extensions () X "Toggle mode in which calc-ext extensions are loaded automatically with calc." X (interactive) X (calc-wrapper X (if (setq calc-always-load-extensions (not calc-always-load-extensions)) X (message "Always loading extensions package.") X (message "Loading extensions package on demand only."))) X) X X(defun calc-degrees-mode () X "Set Calculator to use degrees for all angles." X (interactive) X (calc-wrapper X (setq calc-angle-mode 'deg) X (message "Angles measured in degrees.")) X) X X(defun calc-radians-mode () X "Set Calculator to use degrees for all angles." X (interactive) X (calc-wrapper X (setq calc-angle-mode 'rad) X (message "Angles measured in radians.")) X) X X(defun calc-hms-mode () X "Set Calculator to use degrees-minutes-seconds for all angles." X (interactive) X (calc-wrapper X (setq calc-angle-mode 'hms) X (message "Angles measured in degrees-minutes-seconds.")) X) X X(defun calc-polar-mode (n) X "Toggle mode complex number preference between rectangular and polar forms." X (interactive "P") X (calc-wrapper X (if (if n X (> (prefix-numeric-value n) 0) X (eq calc-complex-mode 'cplx)) X (progn X (setq calc-complex-mode 'polar) X (message "Preferred complex form is polar.")) X (setq calc-complex-mode 'cplx) X (message "Preferred complex form is rectangular."))) X) X X(defun calc-frac-mode (n) X "Toggle mode in which Calculator prefers fractions over floats. XWith positive prefix argument, sets mode on (fractions). XWith negative or zero prefix argument, sets mode off (floats)." X (interactive "P") X (calc-wrapper X (if (if n X (> (prefix-numeric-value n) 0) X (not calc-prefer-frac)) X (progn X (setq calc-prefer-frac t) X (message "Integer division will now generate fractions.")) X (setq calc-prefer-frac nil) X (message "Integer division will now generate floating-point results."))) X) X X X X X;;; Trail commands. X X(defun calc-t-prefix-help () X (interactive) X (calc-do-prefix-help X '("Display; Fwd, Back; Next, Prev, Here, [, ]; Yank" X "Search, Reverse; In, Out; <, >; Kill; Marker") X "trail" ?t) X) X X(defun calc-trail-in () X "Switch to the Calc Trail window." X (interactive) X (let ((win (get-buffer-window (calc-trail-display t)))) X (and win (select-window win))) X) X X(defun calc-trail-out () X "Switch back to the main Calculator window." X (interactive) X (calc-select-buffer) X (let ((win (get-buffer-window (current-buffer)))) X (if win X (select-window win) X (calc))) X) X X(defmacro calc-with-trail-buffer (&rest body) X (` (let ((save-buf (current-buffer)) X (calc-command-flags nil)) X (unwind-protect X (, (append '(progn X (set-buffer (calc-trail-display t)) X (or (eq major-mode 'calc-trail-mode) X (error "Calc Trail buffer is not usable")) X (goto-char calc-trail-pointer)) X body)) X (set-buffer save-buf)))) X) X X(defun calc-trail-next (n) X "Move the trail pointer down one line." X (interactive "p") X (calc-with-trail-buffer X (forward-line n) X (calc-trail-here)) X) X X(defun calc-trail-previous (n) X "Move the trail pointer up one line." X (interactive "p") X (calc-with-trail-buffer X (forward-line (- n)) X (calc-trail-here)) X) X X(defun calc-trail-first (n) X "Move the trail pointer to the beginning of the trail." X (interactive "p") X (calc-with-trail-buffer X (goto-char (point-min)) X (forward-line n) X (calc-trail-here)) X) X X(defun calc-trail-last (n) X "Move the trail pointer to the end of the trail." X (interactive "p") X (calc-with-trail-buffer X (goto-char (point-max)) X (forward-line (- n)) X (calc-trail-here)) X) X X(defun calc-trail-scroll-left (n) X "Scroll the trail window horizontally to the left." X (interactive "P") X (let ((curwin (selected-window))) X (calc-with-trail-buffer X (unwind-protect X (progn X (select-window (get-buffer-window (current-buffer))) X (calc-scroll-left n)) X (select-window curwin)))) X) X X(defun calc-trail-scroll-right (n) X "Scroll the trail window horizontally to the right." X (interactive "P") X (let ((curwin (selected-window))) X (calc-with-trail-buffer X (unwind-protect X (progn X (select-window (get-buffer-window (current-buffer))) X (calc-scroll-right n)) X (select-window curwin)))) X) X X(defun calc-trail-forward (n) X "Move the trail pointer forward one page." X (interactive "p") X (calc-with-trail-buffer X (forward-line (* n (1- (window-height)))) X (calc-trail-here)) X) X X(defun calc-trail-backward (n) X "Move the trail pointer backward one page." X (interactive "p") X (calc-with-trail-buffer X (forward-line (- (* n (1- (window-height))))) X (calc-trail-here)) X) X X(defun calc-trail-isearch-forward () X "Search incrementally forward in the trail buffer." X (interactive) X (calc-with-trail-buffer X (save-window-excursion X (select-window (get-buffer-window (current-buffer))) X (isearch t nil)) X (calc-trail-here)) X) X X(defun calc-trail-isearch-backward () X "Search incrementally backward in the trail buffer." X (interactive) X (calc-with-trail-buffer X (save-window-excursion X (select-window (get-buffer-window (current-buffer))) X (isearch nil nil)) X (calc-trail-here)) X) X X(defun calc-trail-yank () X "Yank the value indicated by the trail pointer onto the Calculator stack." X (interactive) X (calc-wrapper X (calc-set-command-flag 'hold-trail) X (calc-enter-result 0 "yank" X (calc-with-trail-buffer X (if (or (looking-at "Emacs Calc") X (looking-at "----") X (looking-at " ? ? ?[^ \n]* *$") X (looking-at "..?.?$")) X (error "Can't yank that line")) X (forward-char 4) X (search-forward " ") X (let* ((next (save-excursion (forward-line 1) (point))) X (str (buffer-substring (point) (1- next))) X (calc-language nil) X (math-expr-opers math-standard-opers) X (val (math-read-expr str))) X (if (eq (car-safe val) 'error) X (error "Can't yank that line: " (nth 2 val)) X val))))) X) X X(defun calc-trail-marker (str) X "Put a textual marker into the Calculator trail." X (interactive "sText to insert in trail: ") X (calc-with-trail-buffer X (forward-line 1) X (let ((buffer-read-only nil)) X (insert "---- " str "\n")) X (forward-line -1) X (calc-trail-here)) X) X X(defun calc-trail-kill (n) X "Kill one line from the Calculator trail. XThis line can be yanked into text buffers, but cannot be yanked back into Xthe trail." X (interactive "p") X (calc-with-trail-buffer X (let ((buffer-read-only nil)) X (save-restriction X (narrow-to-region ; don't delete "Emacs Trail" header X (save-excursion X (goto-char (point-min)) X (forward-line 1) X (point)) X (point-max)) X (kill-line n))) X (calc-trail-here)) X) X X X X;;; Units commands. X X(defun calc-u-prefix-help () X (interactive) X (calc-do-prefix-help X '("Simplify, Convert, Temperature-convert, Base-units" X "Remove, eXtract; Explain; View-table" X "Define, Undefine, Get-defn, Permanent") X "units" ?u) X) X X(defun calc-base-units () X "Convert the value on the stack into \"base\" units, like m, g, and s." X (interactive) X (calc-slow-wrapper X (calc-enter-result 1 "bsun" (math-simplify-units X (math-to-standard-units (calc-top-n 1) nil)))) X) X X(defun calc-convert-units (&optional old-units new-units) X "Convert the value on the stack to the specified new units. XUnit name may also be \"si\", \"mks\", or \"cgs\" to convert to that system. XTemperature units are converted as relative temperatures." X (interactive) X (calc-slow-wrapper X (let ((expr (calc-top-n 1)) X (uoldname nil) X unew) X (or (math-units-in-expr-p expr t) X (let ((uold (or old-units X (progn X (setq uoldname (read-string "Old units: ")) X (if (equal uoldname "") X (progn X (setq uoldname "1") X 1) X (math-read-expr uoldname)))))) X (if (eq (car-safe uold) 'error) X (error "Bad format in units expression: %s" (nth 1 uold))) X (setq expr (math-mul expr uold)))) X (or new-units X (setq new-units (read-string (if uoldname X (concat "Old units: " X uoldname X ", new units: ") X "New units: ")))) X (setq units (math-read-expr new-units)) X (if (eq (car-safe units) 'error) X (error "Bad format in units expression: %s" (nth 2 units))) X (let ((unew (math-units-in-expr-p units t)) X (std (and (eq (car-safe units) 'var) X (assq (nth 1 units) math-standard-units-systems)))) X (if std X (calc-enter-result 1 "cvun" (math-simplify-units X (math-to-standard-units expr X (nth 1 std)))) X (or unew X (error "No units specified")) X (calc-enter-result 1 "cvun" (math-simplify-units X (math-convert-units expr units))))))) X) X X(defun calc-convert-temperature (&optional old-units new-units) X "Convert the value on the stack to the specified new temperature units. XThis converts absolute temperature, i.e., \"0 degC\" converts to \"32 degF\"." X (interactive) X (calc-slow-wrapper X (let ((expr (calc-top-n 1)) X (uold nil) X (uoldname nil) X unew) X (setq uold (or old-units X (let ((units (math-single-units-in-expr-p expr))) X (if units X (if (consp units) X (list 'var (car units) X (intern (concat "var-" X (symbol-name X (car units))))) X (error "Not a pure temperature expression")) X (math-read-expr X (setq uoldname (read-string X "Old temperature units: "))))))) X (if (eq (car-safe uold) 'error) X (error "Bad format in units expression: %s" (nth 2 uold))) X (or (math-units-in-expr-p expr nil) X (setq expr (math-mul expr uold))) X (setq unew (or new-units X (math-read-expr X (read-string (if uoldname X (concat "Old temperature units: " X uoldname X ", new units: ") X "New temperature units: "))))) X (if (eq (car-safe unew) 'error) X (error "Bad format in units expression: %s" (nth 2 unew))) X (calc-enter-result 1 "cvtm" (math-simplify-units X (math-convert-temperature expr uold unew))))) X) X X(defun calc-remove-units () X "Remove all unit names from the value on the top of the stack." X (interactive) X (calc-slow-wrapper X (calc-enter-result 1 "rmun" (math-simplify-units X (math-remove-units (calc-top-n 1))))) X) X X(defun calc-extract-units () X "Extract the units from the unit expression on the top of the stack." X (interactive) X (calc-slow-wrapper X (calc-enter-result 1 "rmun" (math-simplify-units X (math-extract-units (calc-top-n 1))))) X) X X(defun calc-explain-units () X "Produce an English explanation of the units of the expression on the stack." X (interactive) X (calc-wrapper X (let ((num-units nil) X (den-units nil)) X (calc-explain-units-rec (calc-top-n 1) 1) X (and den-units (string-match "^[^(].* .*[^)]$" den-units) X (setq den-units (concat "(" den-units ")"))) X (if num-units X (if den-units X (message "%s per %s" num-units den-units) X (message "%s" num-units)) X (if den-units X (message "1 per %s" den-units) X (message "No units in expression"))))) X) X X(defun calc-explain-units-rec (expr pow) X (let ((u (math-check-unit-name expr)) X pos) X (if (and u (not (math-zerop pow))) X (let ((name (or (nth 2 u) (symbol-name (car u))))) X (if (eq (aref name 0) ?\*) X (setq name (substring name 1))) X (if (string-match "[^a-zA-Z0-9']" name) X (if (string-match "^[a-zA-Z0-9' ()]*$" name) X (while (setq pos (string-match "[ ()]" name)) X (setq name (concat (substring name 0 pos) X (if (eq (aref name pos) 32) "-" "") X (substring name (1+ pos))))) X (setq name (concat "(" name ")")))) X (or (eq (nth 1 expr) (car u)) X (setq name (concat (nth 2 (assq (aref (symbol-name X (nth 1 expr)) 0) X math-unit-prefixes)) X (if (and (string-match "[^a-zA-Z0-9']" name) X (not (memq (car u) '(mHg gf)))) X (concat "-" name) X (downcase name))))) X (cond ((or (math-equal-int pow 1) X (math-equal-int pow -1))) X ((or (math-equal-int pow 2) X (math-equal-int pow -2)) X (if (equal (nth 4 u) '((m . 1))) X (setq name (concat "Square-" name)) X (setq name (concat name "-squared")))) X ((or (math-equal-int pow 3) X (math-equal-int pow -3)) X (if (equal (nth 4 u) '((m . 1))) X (setq name (concat "Cubic-" name)) X (setq name (concat name "-cubed")))) X (t X (setq name (concat name "^" X (math-format-number (math-abs pow)))))) X (if (math-posp pow) X (setq num-units (if num-units X (concat num-units " " name) X name)) X (setq den-units (if den-units X (concat den-units " " name) X name)))) X (cond ((eq (car-safe expr) '*) X (calc-explain-units-rec (nth 1 expr) pow) X (calc-explain-units-rec (nth 2 expr) pow)) X ((eq (car-safe expr) '/) X (calc-explain-units-rec (nth 1 expr) pow) X (calc-explain-units-rec (nth 2 expr) (- pow))) X ((memq (car-safe expr) '(neg + -)) X (calc-explain-units-rec (nth 1 expr) pow)) X ((and (eq (car-safe expr) '^) X (math-realp (nth 2 expr))) X (calc-explain-units-rec (nth 1 expr) X (math-mul pow (nth 2 expr))))))) X) X X(defun calc-simplify-units () X "Simplify the units expression on top of the stack." X (interactive) X (calc-slow-wrapper X (calc-with-default-simplification X (calc-enter-result 1 "smun" (math-simplify-units (calc-top-n 1))))) X) X X(defun calc-view-units-table (n) X "Display a temporary buffer for displaying the Units Table." X (interactive "P") X (and n (setq math-units-table-buffer-valid nil)) X (math-build-units-table-buffer nil) X) X X(defun calc-enter-units-table (n) X "Switch to a temporary buffer for displaying the Units Table." X (interactive "P") X (and n (setq math-units-table-buffer-valid nil)) X (math-build-units-table-buffer t) X (message (substitute-command-keys "Type \\[calc] to return to the Calculator.")) X) X X(defun calc-define-unit (uname desc) X "Define a new type of unit using the formula on the top of the stack." X (interactive "SDefine unit name: \nsDescription: ") X (calc-wrapper X (let ((form (calc-top-n 1)) X (unit (assq uname math-additional-units))) X (or unit X (setq math-additional-units X (cons (setq unit (list uname nil nil)) X math-additional-units) X math-units-table nil)) X (setcar (cdr unit) (and (not (and (eq (car-safe form) 'var) X (eq (nth 1 form) uname))) X (not (math-equal-int form 1)) X (math-format-flat-expr form 0))) X (setcar (cdr (cdr unit)) (and (not (equal desc "")) X desc)))) X (calc-invalidate-units-table) X) X X(defun calc-undefine-unit (uname) X "Remove the definition of a user-defined unit." X (interactive "SUndefine unit name: ") X (calc-wrapper X (let ((unit (assq uname math-additional-units))) X (or unit X (if (assq uname math-standard-units) X (error "\"%s\" is a predefined unit name" uname) X (error "Unit name \"%s\" not found" uname))) X (setq math-additional-units (delq unit math-additional-units) X math-units-table nil))) X (calc-invalidate-units-table) X) X X(defun calc-invalidate-units-table () X (setq math-units-table nil) X (let ((buf (get-buffer "*Units Table*"))) X (save-excursion X (set-buffer buf) X (save-excursion X (goto-char (point-min)) X (if (looking-at "Calculator Units Table") X (let ((buffer-read-only nil)) X (insert "(Obsolete) ")))))) X) X X(defun calc-get-unit-definition (uname) X "Push the definition of a unit as a formula on the Calculator stack." X (interactive "SGet definition for unit: ") X (calc-wrapper X (math-build-units-table) X (let ((unit (assq uname math-units-table))) X (or unit X (error "Unit name \"%s\" not found" uname)) X (let ((msg (nth 2 unit))) X (if (stringp msg) X (if (string-match "^\\*" msg) X (setq msg (substring msg 1))) X (setq msg (symbol-name uname))) X (if (nth 1 unit) X (progn X (calc-enter-result 0 "ugdf" (nth 1 unit)) X (message "Derived unit: %s" msg)) X (calc-enter-result 0 "ugdf" (list 'var uname X (intern X (concat "var-" X (symbol-name uname))))) X (message "Base unit: %s" msg))))) X) X X(defun calc-permanent-units () X "Save all user-defined units in your .emacs file." X (interactive) X (calc-wrapper X (let (pos) X (set-buffer (find-file-noselect (substitute-in-file-name X calc-settings-file))) X (goto-char (point-min)) X (if (and (search-forward ";;; Custom units stored by Calc" nil t) X (progn X (beginning-of-line) X (setq pos (point)) X (search-forward "\n;;; End of custom units" nil t))) X (progn X (beginning-of-line) X (forward-line 1) X (delete-region pos (point))) X (goto-char (point-max)) X (insert "\n\n") X (forward-char -1)) X (insert ";;; Custom units stored by Calc on " (current-time-string) "\n") X (if math-additional-units X (progn X (insert "(setq math-additional-units '(\n") X (let ((list math-additional-units)) X (while list X (insert " (" (symbol-name (car (car list))) " " X (if (nth 1 (car list)) X (if (stringp (nth 1 (car list))) X (prin1-to-string (nth 1 (car list))) X (prin1-to-string (math-format-flat-expr X (nth 1 (car list)) 0))) X "nil") X " " X (prin1-to-string (nth 2 (car list))) X ")\n") X (setq list (cdr list)))) X (insert "))\n")) X (insert ";;; (no custom units defined)\n")) X (insert ";;; End of custom units\n") X (save-buffer))) X) X X X X X;;; Vector commands. X X(defun calc-v-prefix-help () X (interactive) X (calc-do-prefix-help X '("Pack, Unpack, Identity, Diagonal, indeX, Build" X "Row, Col, Length; rNorm" X "Tranpose, Arrange; Sort, Histogram" X "SHIFT + Det, Inv, LUD, Trace, conJtrn, Cross, cNorm" X "SHIFT + Reduce, Map, Apply" X "<, =, > (justification); , (commas); [, {, ( (brackets)") X "vec/mat" ?v) X) X X(defun calc-concat (arg) X "Concatenate the two vectors at the top of the stack. XOr concatenate a scalar value and a vector." X (interactive "P") X (calc-wrapper X (calc-binary-op "|" 'calcFunc-vconcat arg '(vec))) X) X X(defun calc-matrix-left-justify () X "Left-justify elements of matrices." X (interactive) X (calc-wrapper X (setq calc-matrix-just nil) X (calc-refresh)) X) X X(defun calc-matrix-center-justify () X "Center elements of matrices." X (interactive) X (calc-wrapper X (setq calc-matrix-just 'center) X (calc-refresh)) X) X X(defun calc-matrix-right-justify () X "Right-justify elements of matrices." X (interactive) X (calc-wrapper X (setq calc-matrix-just 'right) X (calc-refresh)) X) X X(defun calc-vector-commas () X "Turn separating commas in vectors on and off." X (interactive) X (calc-wrapper X (setq calc-vector-commas (if calc-vector-commas nil ",")) X (calc-refresh)) X) X X(defun calc-vector-brackets () X "Surround vectors and matrices with square brackets. XIf already using brackets, turn the brackets off." X (interactive) X (calc-wrapper X (setq calc-vector-brackets (if (equal calc-vector-brackets "[]") nil "[]")) X (calc-refresh)) X) X X(defun calc-vector-braces () X "Surround vectors and matrices with curly braces. XIf already using braces, turn the braces off." X (interactive) X (calc-wrapper X (setq calc-vector-brackets (if (equal calc-vector-brackets "{}") nil "{}")) X (calc-refresh)) X) X X(defun calc-vector-parens () X "Surround vectors and matrices with parentheses. XIf already using parens, turn the parens off." X (interactive) X (calc-wrapper X (setq calc-vector-brackets (if (equal calc-vector-brackets "()") nil "()")) X (calc-refresh)) X) X X(defun calc-pack (n) X "Pack the top two numbers on the Calculator stack into a complex number. XGiven a numeric prefix, pack the top N numbers into a vector. XGiven a -1 prefix, pack the top 2 numbers into a rectangular complex number. XGiven a -2 prefix, pack the top 2 numbers into a polar complex number. XGiven a -3 prefix, pack the top 3 numbers into an HMS form. XGiven a -4 prefix, pack the top 2 numbers into an error form. XGiven a -5 prefix, pack the top 2 numbers into a modulo form. XGiven a -6 prefix, pack the top 2 numbers into a [ .. ] interval form. XGiven a -7 prefix, pack the top 2 numbers into a [ .. ) interval form. XGiven a -8 prefix, pack the top 2 numbers into a ( .. ] interval form. XGiven a -9 prefix, pack the top 2 numbers into a ( .. ) interval form." X (interactive "P") X (calc-wrapper X (let ((num (prefix-numeric-value n))) X (cond ((and n (>= num 0)) X (calc-enter-result num nil (cons 'vec (calc-top-list num)))) X ((= num -3) X (let ((h (calc-top 3)) X (m (calc-top 2)) X (s (calc-top 1))) X (if (and (math-num-integerp h) X (math-num-integerp m)) X (calc-enter-result 3 nil (list 'hms h m s)) X (error "Hours and minutes must be integers")))) X ((= num -4) X (let ((x (calc-top-n 2)) X (sigma (calc-top-n 1))) X (if (and (or (math-anglep x) (not (math-objvecp x))) X (or (math-anglep sigma) (not (math-objvecp sigma)))) X (calc-enter-result 2 nil (math-make-sdev x sigma)) X (error "Components must be real")))) X ((= num -5) X (let ((a (calc-top-n 2)) X (m (calc-top-n 1))) X (if (and (math-anglep a) (math-anglep m)) X (if (math-posp m) X (calc-enter-result 2 nil (math-make-mod a m)) X (error "Modulus must be positive")) X (error "Components must be real")))) X ((memq num '(-6 -7 -8 -9)) X (let ((lo (calc-top-n 2)) X (hi (calc-top-n 1))) X (if (and (or (math-anglep lo) (not (math-objvecp lo))) X (or (math-anglep hi) (not (math-objvecp hi)))) X (calc-enter-result 2 nil (math-make-intv (+ num 6) lo hi)) X (error "Components must be real")))) X ((or (= num -2) X (and (eq calc-complex-mode 'polar) X (= num 0))) X (let ((r (calc-top 2)) X (theta (calc-top 1))) X (if (and (math-realp r) (math-anglep theta)) X (calc-enter-result 2 nil (list 'polar r theta)) X (error "Components must be real")))) X (t X (let ((real (calc-top 2)) X (imag (calc-top 1))) X (if (and (math-realp real) (math-realp imag)) X (calc-enter-result 2 nil (list 'cplx real imag)) X (error "Components must be real"))))))) X) X X(defun calc-unpack () X "Unpack complex number, vector, HMS form, error form, etc. at top of stack." X (interactive) X (calc-wrapper X (let ((num (calc-top))) X (if (or (and (not (memq (car-safe num) '(cplx polar vec hms sdev mod))) X (math-objvecp num)) X (eq (car-safe num) 'var)) X (error "Argument must be a vector, complex number, or HMS, error, or modulo form")) X (calc-pop-push-list 1 (cdr num)))) X) X X(defun calc-diag (n) X "Build an NxN element diagonal matrix out of top-of-stack. XIf top-of-stack is a vector, numeric prefix N must match or be omitted. XIf top-of-stack is a scalar, numeric prefix N is required." X (interactive "P") X (calc-wrapper X (calc-enter-result 1 "diag" (if n X (list 'calcFunc-diag (calc-top-n 1) X (prefix-numeric-value n)) X (list 'calcFunc-diag (calc-top-n 1))))) X) X X(defun calc-ident (n) X "Push an NxN element identity matrix on the stack." X (interactive "NDimension of identity matrix = ") X (calc-wrapper X (calc-enter-result 0 "idn" (list 'calcFunc-diag 1 X (prefix-numeric-value n)))) X) X X(defun calc-index (n) X "Generate a vector of the form [1, 2, ..., N]." X (interactive "NSize of vector = ") X (calc-wrapper X (calc-enter-result 0 "indx" (list 'calcFunc-index X (prefix-numeric-value n)))) X) X X(defun calc-build-vector (n) X "Generate a vector of N copies of top-of-stack." X (interactive "NSize of vector = ") X (calc-wrapper X (calc-enter-result 1 "bldv" (list 'calcFunc-cvec X (calc-top-n 1) X (prefix-numeric-value n)))) X) X X(defun calc-vlength (arg) X "Replace a vector with its length, in the form of an integer." X (interactive "P") X (calc-wrapper X (calc-unary-op "len" 'calcFunc-vlen arg)) X) X X(defun calc-arrange-vector (n) X "Rearrange a matrix to have a specific number of columns." X (interactive "NNumber of columns = ") X (calc-wrapper X (calc-enter-result 1 "arng" (list 'calcFunc-arrange (calc-top-n 1) X (prefix-numeric-value n)))) X) X X(defun calc-sort () X "Sort the matrix at top of stack into increasing order. XWith Inverse flag or a negative numeric prefix, sort into decreasing order." X (interactive) X (calc-slow-wrapper X (if (calc-is-inverse) X (calc-enter-result 1 "rsrt" (list 'calcFunc-rsort (calc-top-n 1))) X (calc-enter-result 1 "sort" (list 'calcFunc-sort (calc-top-n 1))))) X) X X(defun calc-histogram (n) X "Compile a histogram of a vector of integers in the range [0..N). XN is the numeric prefix argument. XWith Hyperbolic flag, top-of-stack is a vector of weights to associate Xwith elements of next-to-top." X (interactive "NNumber of bins: ") X (calc-slow-wrapper X (if calc-hyperbolic-flag X (calc-enter-result 2 "hist" (list 'calcFunc-histogram X (calc-top-n 2) X (calc-top-n 1) X (prefix-numeric-value n))) X (calc-enter-result 1 "hist" (list 'calcFunc-histogram X (calc-top-n 1) X 1 X (prefix-numeric-value n))))) X) X X(defun calc-transpose (arg) X "Replace the matrix at top of stack with its transpose." X (interactive "P") X (calc-wrapper X (calc-unary-op "trn" 'calcFunc-trn arg)) X) X X(defun calc-conj-transpose (arg) X "Replace the matrix at top of stack with its conjugate transpose." X (interactive "P") X (calc-wrapper X (calc-unary-op "ctrn" 'calcFunc-ctrn arg)) X) X X(defun calc-cross (arg) X "Compute the right-handed cross product of two 3-vectors." X (interactive "P") X (calc-wrapper X (calc-binary-op "cros" 'calcFunc-cross arg)) X) X X(defun calc-mdet (arg) X "Compute the determinant of the square matrix on the top of the stack." X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "mdet" 'calcFunc-det arg)) X) X X(defun calc-mtrace (arg) X "Compute the trace of the square matrix on the top of the stack." X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "mtr" 'calcFunc-tr arg)) X) X X(defun calc-mlud (arg) X "Perform an L-U decomposition of the matrix on the top of the stack. XResult is a vector of two matrices, L and U." X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "mlud" 'calcFunc-lud arg)) X) X X(defun calc-rnorm (arg) X "Compute the row norm of the vector or matrix on the top of the stack. XThis is the maximum row-absolute-value-sum of the matrix. XFor a vector, this is the maximum of the absolute values of the elements." X (interactive "P") X (calc-wrapper X (calc-unary-op "rnrm" 'calcFunc-rnorm arg)) X) X X(defun calc-cnorm (arg) X "Compute the column norm of the vector or matrix on the top of the stack. XThis is the maximum column-absolute-value-sum of the matrix. XFor a vector, this is the sum of the absolute values of the elements." X (interactive "P") X (calc-wrapper X (calc-unary-op "cnrm" 'calcFunc-cnorm arg)) X) X X(defun calc-mrow (n) X "Replace matrix at top of stack with its Nth row. XNumeric prefix N must be between 1 and the height of the matrix. XIf top of stack is a non-matrix vector, extract its Nth element. XIf N is negative, remove the Nth row (or element)." X (interactive "NRow number: ") X (calc-wrapper X (setq n (prefix-numeric-value n)) X (if (= n 0) X (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1))) X (if (< n 0) X (calc-enter-result 1 "rrow" (list 'calcFunc-mrrow X (calc-top-n 1) (- n))) X (calc-enter-result 1 "mrow" (list 'calcFunc-mrow (calc-top-n 1) n))))) X) X X(defun calc-mcol (n) X "Replace matrix at top of stack with its Nth column. XNumeric prefix N must be between 1 and the width of the matrix. XIf top of stack is a non-matrix vector, extract its Nth element. XIf N is negative, remove the Nth column (or element)." X (interactive "NColumn number: ") X (calc-wrapper X (setq n (prefix-numeric-value n)) X (if (= n 0) X (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1))) X (if (< n 0) X (calc-enter-result 1 "rcol" (list 'calcFunc-mrcol X (calc-top-n 1) (- n))) X (calc-enter-result 1 "mcol" (list 'calcFunc-mcol (calc-top-n 1) n))))) X) X X(defun calc-apply (&optional oper) X "Apply an operator to the elements of a vector. XFor example, applying f to [1, 2, 3] produces f(1, 2, 3)." X (interactive) X (calc-wrapper X (let* ((calc-dollar-values (mapcar 'car-safe X (nthcdr calc-stack-top calc-stack))) X (calc-dollar-used 0) X (oper (or oper (calc-get-operator "Apply" X (and (math-vectorp (calc-top 1)) X (1- (length (calc-top 1))))))) X (expr (calc-top-n (1+ calc-dollar-used)))) X (message "Working...") X (calc-set-command-flag 'clear-message) X (calc-enter-result (1+ calc-dollar-used) X (concat (substring "apl" 0 (- 4 (length (nth 2 oper)))) X (nth 2 oper)) X (list 'calcFunc-apply X (math-calcFunc-to-var (nth 1 oper)) X expr)))) X) X X(defun calc-reduce (&optional oper) X "Apply a binary operator across all elements of a vector. XFor example, applying + computes the sum of vector elements." X (interactive) X (calc-wrapper X (let* ((calc-dollar-values (mapcar 'car-safe X (nthcdr calc-stack-top calc-stack))) X (calc-dollar-used 0) X (oper (or oper (calc-get-operator "Reduce" 2)))) X (message "Working...") X (calc-set-command-flag 'clear-message) X (calc-enter-result (1+ calc-dollar-used) X (concat (substring "red" 0 (- 4 (length (nth 2 oper)))) X (nth 2 oper)) X (list (intern (concat "calcFunc-reduce" X (or calc-mapping-dir ""))) X (math-calcFunc-to-var (nth 1 oper)) X (calc-top-n (1+ calc-dollar-used)))))) X) X X(defun calc-map (&optional oper) X "Apply an operator elementwise to one or two vectors. XFor example, applying * computes a vector of products." X (interactive) X (calc-wrapper X (let* ((calc-dollar-values (mapcar 'car-safe X (nthcdr calc-stack-top calc-stack))) X (calc-dollar-used 0) X (oper (or oper (calc-get-operator "Map"))) X (nargs (if (or (equal calc-mapping-dir "a") X (equal calc-mapping-dir "d")) X 1 X (car oper)))) X (message "Working...") X (calc-set-command-flag 'clear-message) X (calc-enter-result (+ nargs calc-dollar-used) X (concat (substring "map" 0 (- 4 (length (nth 2 oper)))) X (nth 2 oper)) X (cons (intern (concat "calcFunc-map" X (or calc-mapping-dir ""))) X (cons (math-calcFunc-to-var (nth 1 oper)) X (calc-top-list-n X nargs X (1+ calc-dollar-used))))))) X) X X;;; Return a list of the form (nargs func name) X(defun calc-get-operator (msg &optional nargs) X (let ((inv nil) (hyp nil) (prefix nil) X done key oper (which 0) X (msgs '( "(Press ? for help)" X "+, -, *, /, ^, %, \\, :, !, |, Neg" X "SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt" X "SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB" X "Binary + And, Or, Xor, Diff; Not, Clip" X "Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction" X "Kombinatorics + Dfact, Lcm, Gcd, Binomial, Perms; Random" X "Matrix-dir + Elements, Rows, Cols, Across, Down" X "X or Z = any function by name; ' = alg entry; $ = stack"))) X (while (not done) X (message "%s%s: %s: %s%s%s" X msg X (cond ((equal calc-mapping-dir "r") " rows") X ((equal calc-mapping-dir "c") " columns") X ((equal calc-mapping-dir "a") " across") X ((equal calc-mapping-dir "d") " down") X (t "")) X (nth which msgs) X (if inv "Inv " "") (if hyp "Hyp " "") X (if prefix (concat (char-to-string prefix) "-") "")) X (setq key (read-char)) X (cond ((= key ?\C-g) X (keyboard-quit)) X ((= key ??) X (setq which (% (1+ which) (length msgs)))) X ((= key ?I) X (setq inv (not inv) X prefix nil)) X ((= key ?H) X (setq hyp (not hyp) X prefix nil)) X ((eq key prefix) X (setq prefix nil)) X ((and (memq key '(?b ?c ?k ?m)) (null prefix)) X (setq inv nil hyp nil X prefix key)) X ((eq prefix ?m) X (setq prefix nil) X (if (eq key ?e) X (setq calc-mapping-dir nil) X (if (memq key '(?r ?c ?a ?d)) X (setq calc-mapping-dir (char-to-string key)) X (beep)))) X ((memq key '(?\$ ?\')) X (let ((expr (if (eq key ?\$) X (progn X (setq calc-dollar-used 1) X (if calc-dollar-values X (list (car calc-dollar-values)) X (error "Stack underflow"))) X (calc-do-alg-entry "" "Function: "))) X (arglist nil)) X (if (/= (length expr) 1) X (error "Bad format")) X (if (eq (car-safe (car expr)) 'calcFunc-lambda) X (setq oper (list "$" (- (length (car expr)) 2) (car expr)) X done t) X (calc-default-formula-arglist (car expr)) X (setq arglist (sort arglist 'string-lessp) X arglist (read-from-minibuffer X "Function argument list: " X (if arglist X (prin1-to-string arglist) X "()") X minibuffer-local-map X t)) X (setq oper (list "$" X (length arglist) X (append '(calcFunc-lambda) X (mapcar X (function X (lambda (x) X (list 'var X x X (intern X (concat X "var-" X (symbol-name x)))))) X arglist) X expr)) X done t)))) X ((setq oper (assq key (cond ((eq prefix ?b) calc-b-oper-keys) X ((eq prefix ?c) calc-c-oper-keys) X ((eq prefix ?k) calc-k-oper-keys) X (inv (if hyp X calc-inv-hyp-oper-keys X calc-inv-oper-keys)) X (t (if hyp X calc-hyp-oper-keys X calc-oper-keys))))) X (if (eq (nth 1 oper) 'user) X (let ((func (intern X (completing-read "Function name: " X obarray 'fboundp X nil "calcFunc-")))) X (if nargs X (setq oper (list "z" nargs func) X done t) X (if (and (fboundp func) X (consp (symbol-function func))) X (let* ((defn (symbol-function func)) X (args (nth 1 defn))) X (if (and (eq (car defn) 'lambda) X args X (not (memq (car args) X '(&optional &rest))) X (or (memq (nth 2 args) X '(&optional &rest nil)) X (memq (nth 1 args) X '(&optional &rest)))) X (setq oper (list "z" X (if (memq (nth 1 args) X '(&optional X &rest nil)) X 1 2) X func) X done t) X (error "Function is not suitable for this operation"))) X (message "Number of arguments: ") X (let ((nargs (read-char))) X (if (and (>= nargs ?0) (<= nargs ?9)) X (setq oper (list "z" (- nargs ?0) func) X done t) X (beep)))))) X (setq done t))) X (t (beep)))) X (and nargs X (/= nargs (nth 1 oper)) X (error "Must be a %d-argument operator" nargs)) X (append (cdr oper) X (list X (concat (if prefix (char-to-string prefix) "") X (if inv "I" "") (if hyp "H" "") X (char-to-string key))))) X) X X(defconst calc-oper-keys '( ( ?+ 2 calcFunc-add ) X ( ?- 2 calcFunc-sub ) X ( ?* 2 calcFunc-mul ) X ( ?/ 2 calcFunc-div ) X ( ?^ 2 calcFunc-pow ) X ( ?| 2 calcFunc-vconcat ) X ( ?% 2 calcFunc-mod ) X ( ?\\ 2 calcFunc-idiv ) X ( ?: 2 calcFunc-fdiv ) X ( ?! 1 calcFunc-fact ) X ( ?n 1 calcFunc-neg ) X ( ?x user ) X ( ?z user ) X ( ?A 1 calcFunc-abs ) X ( ?J 1 calcFunc-conj ) X ( ?G 1 calcFunc-arg ) X ( ?Q 1 calcFunc-sqrt ) X ( ?N 2 calcFunc-min ) X ( ?X 2 calcFunc-max ) X ( ?F 1 calcFunc-floor ) X ( ?R 1 calcFunc-round ) X ( ?S 1 calcFunc-sin ) X ( ?C 1 calcFunc-cos ) X ( ?T 1 calcFunc-tan ) X ( ?L 1 calcFunc-ln ) X ( ?E 1 calcFunc-exp ) X ( ?B 2 calcFunc-log ) X)) X(defconst calc-b-oper-keys '( ( ?a 2 calcFunc-and ) X ( ?o 2 calcFunc-or ) X ( ?x 2 calcFunc-xor ) X ( ?d 2 calcFunc-diff ) X ( ?n 1 calcFunc-not ) X ( ?c 1 calcFunc-clip ) X)) X(defconst calc-c-oper-keys '( ( ?d 1 calcFunc-deg ) X ( ?r 1 calcFunc-rad ) X ( ?h 1 calcFunc-hms ) X ( ?f 1 calcFunc-float ) X ( ?F 1 calcFunc-frac ) X)) X(defconst calc-k-oper-keys '( ( ?g 2 calcFunc-gcd ) X ( ?l 2 calcFunc-lcm ) X ( ?b 2 calcFunc-choose ) X ( ?d 1 calcFunc-dfact ) X ( ?m 1 calcFunc-moebius ) X ( ?p 2 calcFunc-perm ) X ( ?r 1 calcFunc-random ) X ( ?t 1 calcFunc-totient ) X)) X(defconst calc-inv-oper-keys '( ( ?F 1 calcFunc-ceil ) X ( ?R 1 calcFunc-trunc ) X ( ?Q 1 calcFunc-sqr ) X ( ?S 1 calcFunc-arcsin ) X ( ?C 1 calcFunc-arccos ) X ( ?T 1 calcFunc-arctan ) X ( ?L 1 calcFunc-exp ) X ( ?E 1 calcFunc-ln ) X)) X(defconst calc-hyp-oper-keys '( ( ?F 1 calcFunc-ffloor ) X ( ?R 1 calcFunc-fround ) X ( ?S 1 calcFunc-sinh ) X ( ?C 1 calcFunc-cosh ) X ( ?T 1 calcFunc-tanh ) X ( ?L 1 calcFunc-log10 ) X ( ?E 1 calcFunc-exp10 ) X)) X(defconst calc-inv-hyp-oper-keys '( ( ?F 1 calcFunc-fceil ) X ( ?R 1 calcFunc-ftrunc ) X ( ?S 1 calcFunc-arcsinh ) X ( ?C 1 calcFunc-arccosh ) X ( ?T 1 calcFunc-arctanh ) X ( ?L 1 calcFunc-exp10 ) X ( ?E 1 calcFunc-log10 ) X)) X X X X X;;; User menu. X X(defun calc-user-key-map () X (cdr (elt calc-mode-map ?z)) X) X X(defun calc-z-prefix-help () X (interactive) X (let* ((msgs nil) X (buf "") X (kmap (sort (copy-sequence (calc-user-key-map)) X (function (lambda (x y) (< (car x) (car y)))))) X (flags (apply 'logior X (mapcar (function X (lambda (k) X (calc-user-function-classify (car k)))) X kmap)))) X (if (= (logand flags 8) 0) X (calc-user-function-list kmap 7) X (calc-user-function-list kmap 1) SHAR_EOF echo "End of part 5" echo "File calc-ext.el is continued in part 6" echo "6" > s2_seq_.tmp exit 0